home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / LOOP.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  10.0 KB  |  269 lines
  1. ; the LOOP Macro
  2.  
  3. (in-package 'SYS)
  4.  
  5. (defmacro loop (&body body)
  6.   (if (symbolp (first body)) (loop-translate body)
  7.       (let ((tag (gensym)))
  8.  `(block nil (tagbody ,tag ,@body (go ,tag))))))
  9.  
  10. (defmacro l (&body body) (pprint (loop-translate body)) nil)
  11.  
  12. (defvar *loop-collect-keywords* '("APPEND" "APPENDING" "COLLECT" "COLLECTING"
  13.       "NCONC" "NCONCING"))
  14.  
  15. (defvar *loop-keywords* '("APPEND" "APPENDING" "AS" "COLLECT" "COLLECTING"
  16.      "DO" "DOING" "FINALLY" "FOR" "IF" "INITIALLY"
  17.               "NAMED" "NCONC" "NCONCING" "UNLESS" "UNTIL"
  18.      "WHEN" "WHILE" "WITH"))
  19.  
  20. (defun loop-keyword? (object)
  21.   (and (symbolp object)
  22.        (member (string object) *loop-keywords* :test #'string-equal)))
  23.  
  24. (defmacro loop-finish () `(go loop-exit-tag))
  25.  
  26. (defun add-loop-bindings (bindings variable value)
  27.   (setf (first bindings)
  28.     (nconc (first bindings)
  29.            (cond ((not (listp variable))
  30.               (list (list variable value)))
  31.              ((relatively-atomic value)
  32.               (generate-loop-destructuring variable value))
  33.              (t (let ((temp (gensym)))
  34.               (add-loop-bindings (rest bindings) temp value)
  35.               (generate-loop-destructuring variable temp)))))))
  36.  
  37. (defun relatively-atomic (form)
  38.   (or (symbolp form)
  39.       (and (member (first form) '(car cdr caar cadr cdar cddr caaar caadr
  40.                   cadar caddr cdaar cdadr cddar cdddr))
  41.        (relatively-atomic (second form))
  42.        (null (cddr form)))))
  43.  
  44. (defun generate-loop-destructuring (variables values)
  45.   (cond ((null variables) ())
  46.     ((atom variables) (list (list variables values)))
  47.     (t (nconc (generate-loop-destructuring
  48.             (car variables) (if (null values) nil `(car ,values)))
  49.           (generate-loop-destructuring
  50.             (cdr variables) (if (null values) nil `(cdr ,values)))))))
  51.  
  52. (defun add-for-bindings (bindings forms variable value)
  53.   (nconc forms
  54.      (cond ((not (listp variable)) `((setf ,variable ,value)))
  55.            ((relatively-atomic value)
  56.         (list (generate-for-destructuring variable value)))
  57.            (t (let ((temp (gensym)))
  58.             (add-loop-bindings bindings temp nil)
  59.             (list `(setf ,temp ,value)
  60.               (generate-for-destructuring variable temp)))))))
  61.  
  62. (defun generate-for-destructuring (variable value)
  63.   (let ((bindings (generate-loop-destructuring variable value)))
  64.     (if (= (length bindings) 1) (cons 'setf (first bindings))
  65.     (cons 'psetf (apply #'nconc bindings)))))
  66.  
  67. (eval-when (eval compile)
  68. (defmacro lppop (x)
  69.   `(if (null ,x) (error "LOOP expression terminates unexpectedly.") (pop ,x))))
  70.  
  71. (defun loop-collect-form (key symbol expression)
  72.   (setf key (aref key 0))
  73.   (cond ((char-equal key #\C) ; COLLECT
  74.      `(nconc ,symbol (list ,expression)))
  75.     ((char-equal key #\A) ; APPEND
  76.      `(append ,symbol ,expression))
  77.     (t ; NCONC
  78.      `(nconc ,symbol ,expression))))
  79.  
  80.  
  81. (defun loop-for-translate (bindings preset-forms reset-forms body for?)
  82.   (let ((key (lppop body)) (temp nil) (temp2 nil) (var nil))
  83.     (tagbody
  84.       next   (unless (symbolp key) (go set))
  85.              (when (loop-keyword? key) (go exit))
  86.              (when (string-equal (string key) "AND")
  87.            (setf key (lppop body))
  88.            (setf temp (string key))
  89.            (if (string-equal temp "FOR") (setf for? 't)
  90.            (if (string-equal temp "AS") (setf for? nil)))
  91.            (go next))
  92.       set    (setf var key)
  93.              (setf key (lppop body))
  94.              (unless (symbolp key)
  95.            (add-loop-bindings bindings var nil) (go next))
  96.              (setf temp (string key))
  97.              (when (string-equal temp "AND")
  98.            (add-loop-bindings bindings var nil) (go next))
  99.              (when (loop-keyword? temp)
  100.            (add-loop-bindings bindings var nil) (go exit))
  101.              (cond ((string-equal temp "=")  ;; "FOR/AS X ="
  102.             (setf key (lppop body))
  103.             (add-loop-bindings bindings var key)
  104.             (unless for? ;; "AS X ="
  105.               (setf reset-forms
  106.                 (add-for-bindings bindings reset-forms var key))
  107.               (setf key (lppop body)) (go next))
  108.             (setf key (lppop body))
  109.             (unless (and (symbolp key)
  110.                  (string-equal (string key) "THEN"))
  111.               (go next)) ;; "FOR X = Y THEN"
  112.             (setf key (lppop body))
  113.             (setf reset-forms
  114.               (add-for-bindings bindings reset-forms var key))
  115.             (setf key (lppop body))
  116.             (go next))
  117.            ((member temp '("FROM" "DOWNFROM" "UPFROM")
  118.                 :test #'string-equal)
  119.             (unless for? (error "Bad LOOP phrase: AS ~S ~A" var temp))
  120.             (let ((by (cond ((string-equal temp "UPFROM") 1)
  121.                     ((string-equal temp "DOWNFROM") -1)
  122.                     (t nil))))
  123.               (setf key (lppop body))
  124.               (add-loop-bindings bindings var key)
  125.               (setf key (lppop body))
  126.               (unless (symbolp key)
  127.             (setf reset-forms
  128.                   (add-for-bindings bindings reset-forms var
  129.                         `(+ ,var ,(or by 1))))
  130.             (go next))
  131.               (setf temp2 (string key))
  132.               (setf key (lppop body))
  133.               (when (string-equal temp2 "BY")
  134.             (when by (error "Ill-formed LOOP FOR: ~S ~A BY ..."
  135.                     var temp))
  136.             (setf reset-forms
  137.                   (add-for-bindings bindings reset-forms var
  138.                         `(+ ,var ,key)))
  139.             (go next))
  140.               (unless (member temp2 '("TO" "DOWNTO" "UPTO"
  141.                           "BELOW" "ABOVE")
  142.                       :test #'string-equal)
  143.             (setf reset-forms
  144.                   (add-for-bindings bindings reset-forms var
  145.                               `(+ ,var ,(or by 1))))
  146.             (go next))
  147.               (BREAK)))
  148.            ((string-equal temp "IN")
  149.             (setf key (lppop body))
  150.             (setf temp (gensym))
  151.             (add-loop-bindings bindings temp key)
  152.             (setf preset-forms
  153.               (nconc preset-forms
  154.                  `((if (null ,temp) (loop-finish)))))
  155.             (setf preset-forms
  156.               (add-for-bindings bindings preset-forms var `(car ,temp)))
  157.             (setf key (lppop body))
  158.             (cond ((and (symbolp key) (string-equal (string key) "BY"))
  159.                (setf key (lppop body))
  160.                (setf reset-forms
  161.                  (add-for-bindings bindings reset-forms temp
  162.                            `(funcall ,key ,temp)))
  163.                (setf key (lppop body)))
  164.               (t (setf reset-forms
  165.                    (add-for-bindings bindings reset-forms temp
  166.                              `(cdr ,temp)))))
  167.             (go next))
  168.            (t (error "FOR/AS keyword expected in LOOP expression: ~S"
  169.                  key)))
  170.       exit)
  171.     (values preset-forms reset-forms body key)))
  172.  
  173. (defun loop-translate (body)
  174.   (do ((name nil)                ; Loop name.
  175.        (bindings ())                ; LET bindings to be made.
  176.        (forms ())                ; DO forms.
  177.        (init-forms ())                ; Loop initialization forms.
  178.        (exit-forms ())                ; Loop finish forms.
  179.        (preset-forms ())            ; Loop prepass var reset forms.
  180.        (reset-forms ())                ; Loop pass var reset forms.
  181.        (key (lppop body))            ; Next keyword to process.
  182.        (temp nil))
  183.       ((null body)
  184.        (do ((answer `(tagbody ,@init-forms loop-enter-tag
  185.                   ,@preset-forms ,@forms ,@reset-forms
  186.                   (go loop-enter-tag)
  187.                   loop-exit-tag ,@exit-forms)
  188.             (let ((binding (pop bindings)))
  189.               (if (null binding) answer
  190.               `(let ,binding ,answer)))))
  191.        ((null bindings) `(block ,name ,answer))))
  192.     (if (not (symbolp key))
  193.     (error "Random form where LOOP keyword expected: ~S" key))
  194.     (setf key (string key))
  195.     (cond ((string-equal key "NAMED")
  196.        (if name (error "LOOP body contains two NAMED keys."))
  197.        (setf name (lppop body))
  198.        (unless (symbolp name) (error "Bad LOOP name: ~S" name))
  199.        (setf key (lppop body)))
  200.       ((string-equal key "INITIALLY")
  201.        (loop (setf key (lppop body))
  202.              (if (loop-keyword? key) (return nil))
  203.              (setf init-forms (nconc init-forms (list key)))
  204.              (unless body (return nil))))
  205.       ((string-equal key "FINALLY")
  206.        (loop (setf key (pop body))
  207.              (if (loop-keyword? key) (return nil))
  208.              (when (and (symbolp key)
  209.                 (string-equal (string key) "RETURN"))
  210.            (setf exit-forms
  211.              (nconc exit-forms `((return ,(lppop body)))))
  212.            (setf key (lppop body))
  213.            (return nil))
  214.              (setf exit-forms (nconc exit-forms (list key)))
  215.              (unless body (return nil))))
  216.       ((string-equal key "WHILE")
  217.        (setf temp (lppop body))
  218.        (setf key (lppop body))
  219.        (setf forms (nconc forms `((unless ,temp (loop-finish))))))
  220.       ((string-equal key "UNTIL")
  221.        (setf temp (lppop body))
  222.        (setf key (lppop body))
  223.        (setf forms (nconc forms `((when ,temp (loop-finish))))))
  224.       ((string-equal key "WITH")
  225.        (when forms (error "WITH before executable in LOOP BODY."))
  226.        (setf bindings (list* () () bindings))
  227.        (setf key (lppop body))
  228.        (tagbody
  229.          next   (unless (symbolp key) (go set))
  230.             (when (loop-keyword? key) (go exit))
  231.                 (when (string-equal (string key) "AND")
  232.               (setf key (lppop body)) (go next))
  233.          set    (setf temp key)
  234.                 (setf key (lppop body))
  235.                 (cond ((and (symbolp key) (string-equal (string key) "="))
  236.                (setf key (lppop body))
  237.                (add-loop-bindings bindings temp key)
  238.                (setf key (lppop body)))
  239.               (t (add-loop-bindings bindings temp nil)))
  240.                 (go next)
  241.          exit))
  242.       ((or (setf temp (string-equal key "FOR")) (string-equal key "AS"))
  243.        (setf bindings (list* () () bindings))
  244.        (multiple-value-setq (preset-forms reset-forms body key)
  245.          (loop-for-translate bindings preset-forms reset-forms body temp)))
  246.       ((or (string-equal key "DO") (string-equal key "DOING"))
  247.        (loop (setf key (pop body))
  248.              (if (loop-keyword? key) (return nil))
  249.              (setf forms (nconc forms (list key)))
  250.              (unless body (return nil))))
  251.       ((member key *loop-collect-keywords* :test #'string-equal)
  252.        (setf temp key)
  253.        (setf bindings (list* () () bindings))
  254.        (let ((exp (lppop body)) (symbol (gensym)))
  255.          (setf key (pop body))
  256.          (when (and key (symbolp key)
  257.             (member (string key) '("IN" "INTO")
  258.                 :test #'string-equal))
  259.            (setf symbol (lppop body))
  260.            (setf key (pop body)))
  261.          (add-loop-bindings bindings symbol nil)
  262.          (setf forms
  263.            (nconc forms
  264.               `((setf ,symbol
  265.                   ,(loop-collect-form temp symbol exp)))))
  266.          (setf exit-forms
  267.            (nconc exit-forms (list (list 'return symbol))))))
  268.       )))
  269.